home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / mosmllib / Parsing.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  6.2 KB  |  189 lines  |  [TEXT/R*ch]
  1. (* Internal interface to the parsing engine *)
  2.  
  3. open Vector Obj Lexing;
  4.  
  5. type parseTables =
  6.     (* actions *)    (unit -> obj) vector  *
  7.     (* transl *)     int vector *
  8.     (* lhs *)        string *
  9.     (* len *)        string *
  10.     (* defred *)     string *
  11.     (* dgoto *)      string *
  12.     (* sindex *)     string *
  13.     (* rindex *)     string *
  14.     (* gindex *)     string *
  15.     (* tablesize *)  int *
  16.     (* table *)      string *
  17.     (* check *)      string
  18. ;
  19.  
  20. prim_val getActions   : parseTables -> (unit -> obj) vector = 1 "field0";
  21. prim_val getTransl    : parseTables -> int vector           = 1 "field1";
  22.  
  23. exception yyexit of obj;
  24. exception ParseError of (obj -> bool);
  25.  
  26. type parserEnv =
  27.   (* sStack *)          int vector *  (* States *)
  28.   (* vStack  *)         obj vector *  (* Semantic attributes *)
  29.   (* symbStartStack  *) int vector *  (* Start positions *)
  30.   (* symbEndStack *)    int vector *  (* End positions *)
  31.   (* stackSize  *)      int *         (* Size of the stacks *)
  32.   (* currChar  *)       int *         (* Last token read *)
  33.   (* LVal  *)           obj *         (* Its semantic attribute *)
  34.   (* symbStart  *)      int *         (* Start pos. of the current symbol*)
  35.   (* symbEnd  *)        int *         (* End pos. of the current symbol *)
  36.   (* SP  *)             int *         (* The stack pointer *)
  37.   (* ruleLen  *)        int *         (* Number of rsh items in the rule *)
  38.   (* ruleNumber *)      int           (* Rule number to reduce by *)
  39. ;
  40.  
  41. prim_val getSStack         : parserEnv -> int vector = 1 "field0";
  42. prim_val getVStack         : parserEnv -> obj vector = 1 "field1";
  43. prim_val getSymbStartStack : parserEnv -> int vector = 1 "field2";
  44. prim_val getSymbEndStack   : parserEnv -> int vector = 1 "field3";
  45. prim_val getStackSize      : parserEnv -> int        = 1 "field4";
  46. prim_val getCurrChar       : parserEnv -> int        = 1 "field5";
  47. prim_val getLVal           : parserEnv -> obj        = 1 "field6";
  48. prim_val getSymbStart      : parserEnv -> int        = 1 "field7";
  49. prim_val getSymbEnd        : parserEnv -> int        = 1 "field8";
  50. prim_val getSP             : parserEnv -> int        = 1 "field9";
  51. prim_val getRuleLen        : parserEnv -> int        = 1 "field10";
  52. prim_val getRuleNumber     : parserEnv -> int        = 1 "field11";
  53.  
  54. prim_val setSStack         : parserEnv -> int vector -> unit = 2 "setfield0";
  55. prim_val setVStack         : parserEnv -> obj vector -> unit = 2 "setfield1";
  56. prim_val setSymbStartStack : parserEnv -> int vector -> unit = 2 "setfield2";
  57. prim_val setSymbEndStack   : parserEnv -> int vector -> unit = 2 "setfield3";
  58. prim_val setStackSize      : parserEnv -> int       -> unit = 2 "setfield4";
  59. prim_val setCurrChar       : parserEnv -> int       -> unit = 2 "setfield5";
  60. prim_val setLVal           : parserEnv -> obj       -> unit = 2 "setfield6";
  61. prim_val setSymbStart      : parserEnv -> int       -> unit = 2 "setfield7";
  62. prim_val setSymbEnd        : parserEnv -> int       -> unit = 2 "setfield8";
  63. prim_val setSP             : parserEnv -> int       -> unit = 2 "setfield9";
  64. prim_val setRuleLen        : parserEnv -> int       -> unit = 2 "setfield10";
  65. prim_val setRuleNumber     : parserEnv -> int       -> unit = 2 "setfield11";
  66.  
  67. datatype parserInput =
  68.     Start
  69.   | Token_read
  70.   | Stacks_grown_1
  71.   | Stacks_grown_2
  72.   | Semantic_action_computed
  73.  
  74. and parserOutput =
  75.     Read_token
  76.   | Raise_parse_error
  77.   | Grow_stacks_1
  78.   | Grow_stacks_2
  79.   | Compute_semantic_action
  80. ;
  81.  
  82. prim_val parseEngine :
  83.     parseTables -> parserEnv -> parserInput -> obj -> parserOutput
  84.     = 4 "parse_engine"
  85. ;
  86.  
  87. prim_val vector_ : int -> '_a -> '_a vector       = 2 "make_vect";
  88. prim_val sub_    : 'a vector -> int -> 'a         = 2 "get_vect_item";
  89. prim_val update_ : 'a vector -> int -> 'a -> unit = 3 "set_vect_item";
  90.  
  91. (* The parsing engine *)
  92.  
  93. val env : parserEnv =
  94.   ( vector_ 100 0,
  95.     vector_ 100 (repr ()),
  96.     vector_ 100 0,
  97.     vector_ 100 0,
  98.     100, 0, repr (), 0, 0, 0, 0, 0 )
  99. ;
  100.  
  101. fun copyStack oldS newS oldsize =
  102.   let fun h i =
  103.         if i < 0 then ()
  104.         else (update_ newS i (sub_ oldS i); h (i-1))
  105.   in h (oldsize - 1) end
  106. ;
  107.  
  108. fun clearStack stack size v =
  109.   let fun h i =
  110.         if i < 0 then ()
  111.         else (update_ stack i v; h (i-1))
  112.   in h (size - 1) end
  113. ;
  114.  
  115. fun growStacks() =
  116.   let
  117.     val oldsize   = getStackSize env
  118.     val newsize   = oldsize * 2
  119.     val new_s     = vector_ newsize 0
  120.     val new_v     = vector_ newsize (repr ())
  121.     val new_start = vector_ newsize 0
  122.     val new_end   = vector_ newsize 0
  123.   in
  124.     copyStack (getSStack env) new_s oldsize;
  125.     setSStack env new_s;
  126.     copyStack (getVStack env) new_v oldsize;
  127.     setVStack env new_v;
  128.     copyStack (getSymbStartStack env) new_start oldsize;
  129.     setSymbStartStack env new_start;
  130.     copyStack (getSymbEndStack env) new_end oldsize;
  131.     setSymbEndStack env new_end;
  132.     setStackSize env newsize
  133.   end
  134. ;
  135.  
  136. fun clearParser() =
  137.   (clearStack (getVStack env) (getStackSize env) (repr ());
  138.    setLVal env (repr ()))
  139. ;
  140.  
  141. fun yyparse (tables : parseTables) start lexer lexbuf =
  142.   let
  143.     fun loop cmd arg =
  144.     case (parseEngine tables env cmd arg) of
  145.       Read_token =>
  146.         let val t = repr(lexer lexbuf) in
  147.           setSymbStart env (getLexAbsPos lexbuf + getLexStartPos lexbuf);
  148.           setSymbEnd env  (getLexAbsPos lexbuf + getLexCurrPos lexbuf);
  149.           loop Token_read t
  150.         end
  151.     | Raise_parse_error =>
  152.         let val c = getCurrChar env in
  153.           raise ParseError
  154.             (fn tok => sub_ (getTransl tables) (obj_tag tok) = c)
  155.         end
  156.     | Compute_semantic_action =>
  157.         loop Semantic_action_computed
  158.           (sub_ (getActions tables) (getRuleNumber env) ())
  159.     | Grow_stacks_1 =>
  160.         (growStacks(); loop Stacks_grown_1 (repr ()))
  161.     | Grow_stacks_2 =>
  162.         (growStacks(); loop Stacks_grown_2 (repr ()))
  163.   in
  164.     setCurrChar env start;
  165.     setSP env 0;
  166.     (loop Start (repr ()) handle yyexit v => magic_obj v)
  167.   end
  168. ;
  169.  
  170. fun peekVal n =
  171.   magic_obj (sub_ (getVStack env) (getSP env - n))
  172. ;
  173.  
  174. fun symbolStart() =
  175.   sub_ (getSymbStartStack env) (getSP env - getRuleLen env + 1)
  176. ;
  177.  
  178. fun symbolEnd() =
  179.   sub_ (getSymbEndStack env) (getSP env)
  180. ;
  181.  
  182. fun rhsStart n =
  183.   sub_ (getSymbStartStack env) (getSP env - (getRuleLen env - n))
  184. ;
  185.  
  186. fun rhsEnd n =
  187.   sub_ (getSymbEndStack env) (getSP env - (getRuleLen env - n))
  188. ;
  189.